home *** CD-ROM | disk | FTP | other *** search
/ AmigActive 2 / AACD 2.iso / AACD / Programming / fpc / compiler / ptconst.pas < prev    next >
Pascal/Delphi Source File  |  1998-09-24  |  21KB  |  527 lines
  1. {
  2.     $Id: ptconst.pas,v 1.1.1.1.2.1 1998/07/29 12:31:41 carl Exp $
  3.     Copyright (c) 1998 by Florian Klaempfl
  4.  
  5.     Reads typed constants
  6.  
  7.     This program is free software; you can redistribute it and/or modify
  8.     it under the terms of the GNU General Public License as published by
  9.     the Free Software Foundation; either version 2 of the License, or
  10.     (at your option) any later version.
  11.  
  12.     This program is distributed in the hope that it will be useful,
  13.     but WITHOUT ANY WARRANTY; without even the implied warranty of
  14.     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  15.     GNU General Public License for more details.
  16.  
  17.     You should have received a copy of the GNU General Public License
  18.     along with this program; if not, write to the Free Software
  19.     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21.  ****************************************************************************
  22. }
  23. unit ptconst;
  24.  
  25.   interface
  26.  
  27.    uses symtable;
  28.  
  29.     { this procedure reads typed constants }
  30.     procedure readtypedconst(def : pdef);
  31.  
  32.   implementation
  33.  
  34.     uses
  35.        cobjects,globals,scanner,aasm,tree,pass_1,
  36.        hcodegen,types,verbose
  37.        { parser specific stuff }
  38.        ,pbase,pexpr
  39.        { processor specific stuff }
  40. {$ifdef i386}
  41.        ,i386
  42. {$endif}
  43. {$ifdef m68k}
  44.        ,m68k
  45. {$endif}
  46.        ;
  47.  
  48.     { this procedure reads typed constants }
  49.     procedure readtypedconst(def : pdef);
  50.  
  51.       var
  52.          j: integer;
  53.          p : ptree;
  54.          i,l : longint;
  55.          ll : plabel;
  56.          s : string;
  57.          ca : pchar;
  58.          aktpos : longint;
  59.          pd : pprocdef;
  60.          hp1,hp2 : pdefcoll;
  61.  
  62.          value : bestreal;
  63.          {problem with fldt !!
  64.          anyway .valued is not extended !!
  65.          value : double; }
  66.  
  67.       procedure check_range;
  68.  
  69.         begin
  70.            if ((p^.value>porddef(def)^.bis) or
  71.                (p^.value<porddef(def)^.von)) then
  72.              Message(parser_e_range_check_error);
  73.         end;
  74.  
  75. {$R-}  {Range check creates problem with init_8bit(-1) !!}
  76.       begin
  77.          j:=0;
  78.          case def^.deftype of
  79.             orddef:
  80.               begin
  81.                  p:=expr;
  82.                  do_firstpass(p);
  83.                  case porddef(def)^.typ of
  84.                     s8bit,
  85.                     u8bit : begin
  86.                                if not is_constintnode(p) then
  87.                                { is't an int expected }
  88.                                  Message(cg_e_illegal_expression)
  89.                                else
  90.                                  begin
  91.                                     datasegment^.concat(new(pai_const,init_8bit(p^.value)));
  92.                                     check_range;
  93.                                  end;
  94.                             end;
  95.                     s32bit : begin
  96.                                 if not is_constintnode(p) then
  97.                                   Message(cg_e_illegal_expression)
  98.                                 else
  99.                                   begin
  100.                                      datasegment^.concat(new(pai_const,init_32bit(p^.value)));
  101.                                      check_range;
  102.                                   end;
  103.                             end;
  104.                     u32bit : begin
  105.                                 if not is_constintnode(p) then
  106.                                   Message(cg_e_illegal_expression)
  107.                                 else
  108.                                    datasegment^.concat(new(pai_const,init_32bit(p^.value)));
  109.                              end;
  110.                     bool8bit : begin
  111.                                   if not is_constboolnode(p) then
  112.                                     Message(cg_e_illegal_expression);
  113.                                   datasegment^.concat(new(pai_const,init_8bit(p^.value)));
  114.                                end;
  115.                     uchar : begin
  116.                                 if not is_constcharnode(p) then
  117.                                   Message(cg_e_illegal_expression);
  118.                                 datasegment^.concat(new(pai_const,init_8bit(p^.value)));
  119.                             end;
  120.                     u16bit,
  121.                     s16bit : begin
  122.                                 if not is_constintnode(p) then
  123.                                   Message(cg_e_illegal_expression);
  124.                                 datasegment^.concat(new(pai_const,init_16bit(p^.value)));
  125.                                 check_range;
  126.                             end;
  127.                  end;
  128.                  disposetree(p);
  129.               end;
  130.          floatdef:
  131.            begin
  132.               p:=expr;
  133.               do_firstpass(p);
  134.               if is_constrealnode(p) then
  135.                 value:=p^.valued
  136.               else if is_constintnode(p) then
  137.                 value:=p^.value
  138.               else
  139.                 Message(cg_e_illegal_expression);
  140.  
  141.               case pfloatdef(def)^.typ of
  142.                  s64real : datasegment^.concat(new(pai_double,init(value)));
  143.                  s32real : datasegment^.concat(new(pai_single,init(value)));
  144.                  s80real : datasegment^.concat(new(pai_extended,init(value)));
  145.                  s64bit  : datasegment^.concat(new(pai_comp,init(value)));
  146.                  f32bit : datasegment^.concat(new(pai_const,init_32bit(trunc(value*65536))));
  147.               else internalerror(18);
  148.               end;
  149.               disposetree(p);
  150.            end;
  151.          pointerdef:
  152.            begin
  153.               p:=expr;
  154.               do_firstpass(p);
  155.               { nil pointer ? }
  156.               if p^.treetype=niln then
  157.                 datasegment^.concat(new(pai_const,init_32bit(0)))
  158.               { maybe pchar ? }
  159.               else if (ppointerdef(def)^.definition^.deftype=orddef) and
  160.                    (porddef(ppointerdef(def)^.definition)^.typ=uchar) then
  161.                 begin
  162.                    getlabel(ll);
  163.                    { insert string at the begin }
  164.                    if p^.treetype=stringconstn then
  165.                      generate_ascii_insert((p^.values^)+#0)
  166.                    else if is_constcharnode(p) then
  167.                      datasegment^.insert(new(pai_string,init(char(byte(p^.value))+#0)))
  168.                    else Message(cg_e_illegal_expression);
  169.                    datasegment^.insert(new(pai_label,init(ll)));
  170.                    { insert label }
  171.                    datasegment^.concat(new(pai_const,init_symbol(strpnew(lab2str(ll)))));
  172.                 end
  173.               else if p^.treetype=addrn then
  174.                 begin
  175.                    if (is_equal(ppointerdef(p^.resulttype)^.definition,ppointerdef(def)^.definition) or
  176.                       (is_equal(ppointerdef(p^.resulttype)^.definition,voiddef)) or
  177.                       (is_equal(ppointerdef(def)^.definition,voiddef))) and
  178.                       (p^.left^.treetype = loadn) then
  179.                      begin
  180.                         datasegment^.concat(new(pai_const,init_symbol(
  181.                           strpnew(p^.left^.symtableentry^.mangledname))));
  182.                         if p^.left^.symtableentry^.owner^.symtabletype=unitsymtable then
  183.                           concat_external(p^.left^.symtableentry^.mangledname,EXT_NEAR);
  184.                      end
  185.                    else
  186.                      Message(cg_e_illegal_expression);
  187.                 end
  188.               else
  189.               { allow typeof(Object type)}
  190.                 if (p^.treetype=inlinen) and
  191.                    (p^.inlinenumber=in_typeof_x) then
  192.                   if (p^.left^.treetype=typen) then
  193.                     begin
  194.                        datasegment^.concat(new(pai_const,init_symbol(
  195.                          strpnew(pobjectdef(p^.left^.resulttype)^.vmt_mangledname))));
  196.                        if pobjectdef(p^.left^.resulttype)^.owner^.symtabletype=unitsymtable then
  197.                           concat_external(pobjectdef(p^.left^.resulttype)^.vmt_mangledname,EXT_NEAR);
  198.                     end
  199.                   else
  200.                     begin
  201.                        Message(cg_e_illegal_expression);
  202.                     end
  203.                 else
  204.                   Message(cg_e_illegal_expression);
  205.               disposetree(p);
  206.            end;
  207.          setdef:
  208.            begin
  209.               p:=expr;
  210.               do_firstpass(p);
  211.               if p^.treetype=setconstrn then
  212.                 begin
  213.                    { we only allow const sets }
  214.                    if assigned(p^.left) then
  215.                      Message(cg_e_illegal_expression)
  216.                    else
  217.                      begin
  218. {$ifdef i386}
  219.                         for l:=0 to def^.savesize-1 do
  220.                           datasegment^.concat(
  221.                         new(pai_const,init_8bit(p^.constset^[l])));
  222. {$endif}
  223. {$ifdef m68k}
  224.                         for l:=0 to ((def^.savesize-1) div 4) do
  225.                         { HORRIBLE HACK because of endian        }
  226.                         { now use intel endian for constant sets }
  227.                         Begin
  228.                          datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+3])));
  229.                          datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+2])));
  230.                          datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j+1])));
  231.                          datasegment^.concat(new(pai_const,init_8bit(p^.constset^[j])));
  232.                          Inc(j,4);
  233.                         end;
  234.  
  235. {$endif}
  236.                      end;
  237.                 end
  238.               else
  239.                 Message(cg_e_illegal_expression);
  240.               disposetree(p);
  241.            end;
  242.          enumdef:
  243.        begin
  244.               p:=expr;
  245.               do_firstpass(p);
  246.               if p^.treetype=ordconstn then
  247.                 begin
  248.                    if is_equal(p^.resulttype,def) then
  249.                      begin
  250.                         datasegment^.concat(new(pai_const,init_32bit(p^.value)));
  251.                      end
  252.                    else
  253.                      Message(cg_e_illegal_expression);
  254.                 end
  255.               else
  256.                 Message(cg_e_illegal_expression);
  257.               disposetree(p);
  258.            end;
  259.          stringdef:
  260.            begin
  261.               p:=expr;
  262.               do_firstpass(p);
  263.               if pstringdef(def)^.string_typ=shortstring then
  264.                 begin
  265.                    if p^.treetype=stringconstn then
  266.                      begin
  267.                         s:=p^.values^;
  268.                         if length(s)+1>def^.size then
  269.                           s[0]:=char(def^.size-1);
  270.                         generate_ascii(char(length(s))+s);
  271.                      end
  272.                    else if is_constcharnode(p) then
  273.                      begin
  274.                         datasegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
  275.                         s:=char(byte(p^.value));
  276.                      end
  277.                    else Message(cg_e_illegal_expression);
  278.                    if def^.size>length(s) then
  279.                      begin
  280.                         getmem(ca,def^.size-length(s));
  281.                         fillchar(ca[0],def^.size-length(s)-1,' ');
  282.                         ca[def^.size-length(s)-1]:=#0;
  283.                         datasegment^.concat(new(pai_string,init_pchar(ca)));
  284.                         disposetree(p);
  285.                      end;
  286.                 end
  287.               else if pstringdef(def)^.string_typ=longstring then
  288.                 begin
  289.                    if p^.treetype=stringconstn then
  290.                      begin
  291.                         s:=p^.values^;
  292.                         if length(s)+1>def^.size then
  293.                           s[0]:=char(def^.size-1);
  294.                         generate_ascii(char(length(s))+s);
  295.                      end
  296.                    else if is_constcharnode(p) then
  297.                      begin
  298.                         datasegment^.concat(new(pai_string,init(#1+char(byte(p^.value)))));
  299.                         s:=char(byte(p^.value));
  300.                      end
  301.                    else Message(cg_e_illegal_expression);
  302.                    if def^.size>length(s) then
  303.                      begin
  304.                         getmem(ca,def^.size-length(s));
  305.                         fillchar(ca[0],def^.size-length(s)-1,' ');
  306.                         ca[def^.size-length(s)-1]:=#0;
  307.                         datasegment^.concat(new(pai_string,init_pchar(ca)));
  308.                         disposetree(p);
  309.                      end;
  310.                 end
  311.               else if pstringdef(def)^.string_typ=ansistring then
  312.                 begin
  313.                 end
  314.            end;
  315.          arraydef:
  316.            begin
  317.               if token=LKLAMMER then
  318.                 begin
  319.                     consume(LKLAMMER);
  320.                     for l:=parraydef(def)^.lowrange to parraydef(def)^.highrange-1 do
  321.                       begin
  322.                          readtypedconst(parraydef(def)^.definition);
  323.                          consume(COMMA);
  324.                       end;
  325.                     readtypedconst(parraydef(def)^.definition);
  326.                     consume(RKLAMMER);
  327.                  end
  328.               else
  329.                 begin
  330.                    p:=expr;
  331.                    do_firstpass(p);
  332.                    if p^.treetype=stringconstn then
  333.                      s:=p^.values^
  334.                    else if is_constcharnode(p) then
  335.                      s:=char(byte(p^.value))
  336.                    else Message(cg_e_illegal_expression);
  337.                    l:=length(s);
  338.                    for i:=Parraydef(def)^.lowrange to Parraydef(def)^.highrange do
  339.                      begin
  340.                         if i+1-Parraydef(def)^.lowrange<=l then
  341.                           begin
  342.                              datasegment^.concat(new(pai_const,init_8bit(byte(s[1]))));
  343.                              delete(s,1,1);
  344.                           end
  345.                         else
  346.                           {Fill the remaining positions with #0.}
  347.                           datasegment^.concat(new(pai_const,init_8bit(0)));
  348.                      end;
  349.                    if length(s)>0 then
  350.                      Message(parser_e_string_too_long);
  351.                  end;
  352.            end;
  353.          procvardef:
  354.            begin
  355.               { Procvars and pointers are no longer compatible.  }
  356.               { under tp:  =nil or =var under fpc: =nil or =@var }
  357.               if token=_NIL then
  358.                 begin
  359.                    datasegment^.concat(new(pai_const,init_32bit(0)));
  360.                    consume(_NIL);
  361.                    exit;
  362.                 end
  363.               else
  364.               if not(cs_tp_compatible in aktswitches) then
  365.                 if token=KLAMMERAFFE then
  366.                   consume(KLAMMERAFFE);
  367.               getsym(pattern,true);
  368.               consume(ID);
  369.               if srsym^.typ=unitsym then
  370.                       begin
  371.                          consume(POINT);
  372.                          getsymonlyin(punitsym(srsym)^.unitsymtable,pattern);
  373.                          consume(ID);
  374.                       end;
  375.                     if srsym^.typ<>procsym then
  376.                       Message(cg_e_illegal_expression)
  377.                     else
  378.                       begin
  379.                          pd:=pprocsym(srsym)^.definition;
  380.                          if assigned(pd^.nextoverloaded) then
  381.                            Message(parser_e_no_overloaded_procvars);
  382.                          if not((pprocvardef(def)^.options=pd^.options)) or
  383.                            not(is_equal(pprocvardef(def)^.retdef,pd^.retdef)) then
  384.                            Message(sym_e_type_mismatch)
  385.                            else
  386.                               begin
  387.                                  hp1:=pprocvardef(def)^.para1;
  388.                                  hp2:=pd^.para1;
  389.                                  while assigned(hp1) and assigned(hp2) do
  390.                                    begin
  391.                                       if not(is_equal(hp1^.data,hp2^.data)) or
  392.                                          not(hp1^.paratyp=hp2^.paratyp) then
  393.                                         begin
  394.                                            Message(sym_e_type_mismatch);
  395.                                            break;
  396.                                         end;
  397.                                       hp1:=hp1^.next;
  398.                                       hp2:=hp2^.next;
  399.                                    end;
  400.                                  if not((hp1=nil) and (hp2=nil)) then
  401.                                    Message(sym_e_type_mismatch);
  402.                               end;
  403.                          datasegment^.concat(new(pai_const,init_symbol(strpnew(pd^.mangledname))));
  404.                          if pd^.owner^.symtabletype=unitsymtable then
  405.                            concat_external(pd^.mangledname,EXT_NEAR);
  406.                       end;
  407.            end;
  408.          { reads a typed constant record }
  409.          recorddef:
  410.            begin
  411.               consume(LKLAMMER);
  412.               aktpos:=0;
  413.               while token<>RKLAMMER do
  414.                 begin
  415.                    s:=pattern;
  416.                    consume(ID);
  417.                    consume(COLON);
  418.                    srsym:=precdef(def)^.symtable^.search(s);
  419.                    if srsym=nil then
  420.                      begin
  421.                         Message1(sym_e_id_not_found,s);
  422.                         consume_all_until(SEMICOLON);
  423.                      end
  424.                    else
  425.                      begin
  426.                         { check position }
  427.                         if pvarsym(srsym)^.address<aktpos then
  428.                           Message(parser_e_invalid_record_const);
  429.  
  430.                         { if needed fill }
  431.                         if pvarsym(srsym)^.address>aktpos then
  432.                           for i:=1 to pvarsym(srsym)^.address-aktpos do
  433.                             datasegment^.concat(new(pai_const,init_8bit(0)));
  434.  
  435.                         { new position }
  436.                         aktpos:=pvarsym(srsym)^.address+pvarsym(srsym)^.definition^.size;
  437.  
  438.                         { read the data }
  439.                         readtypedconst(pvarsym(srsym)^.definition);
  440.  
  441.                         if token=SEMICOLON then
  442.                           consume(SEMICOLON)
  443.                         else break;
  444.                      end;
  445.                 end;
  446.               for i:=1 to def^.size-aktpos do
  447.                 datasegment^.concat(new(pai_const,init_8bit(0)));
  448.               consume(RKLAMMER);
  449.            end;
  450.          else Message(parser_e_type_const_not_possible);
  451.          end;
  452.       end;
  453.  
  454. end.
  455. {
  456.   $Log: ptconst.pas,v $
  457.   Revision 1.1.1.1.2.1  1998/07/29 12:31:41  carl
  458.     * set constants now have the correct endian
  459.  
  460.   Revision 1.1.1.1  1998/03/25 11:18:15  root
  461.   * Restored version
  462.  
  463.   Revision 1.13  1998/03/20 23:31:35  florian
  464.     * bug0113 fixed
  465.     * problem with interdepened units fixed ("options.pas problem")
  466.     * two small extensions for future AMD 3D support
  467.  
  468.   Revision 1.12  1998/03/18 22:50:11  florian
  469.     + fstp/fld optimization
  470.     * routines which contains asm aren't longer optimzed
  471.     * wrong ifdef TEST_FUNCRET corrected
  472.     * wrong data generation for array[0..n] of char = '01234'; fixed
  473.     * bug0097 is fixed partial
  474.     * bug0116 fixed (-Og doesn't use enter of the stack frame is greater than
  475.       65535)
  476.  
  477.   Revision 1.11  1998/03/13 22:45:59  florian
  478.     * small bug fixes applied
  479.  
  480.   Revision 1.10  1998/03/11 11:23:57  florian
  481.     * bug0081 and bug0109 fixed
  482.  
  483.   Revision 1.9  1998/03/10 01:17:25  peter
  484.     * all files have the same header
  485.     * messages are fully implemented, EXTDEBUG uses Comment()
  486.     + AG... files for the Assembler generation
  487.  
  488.   Revision 1.8  1998/03/06 00:52:50  peter
  489.     * replaced all old messages from errore.msg, only ExtDebug and some
  490.       Comment() calls are left
  491.     * fixed options.pas
  492.  
  493.   Revision 1.7  1998/03/02 01:49:10  peter
  494.     * renamed target_DOS to target_GO32V1
  495.     + new verbose system, merged old errors and verbose units into one new
  496.       verbose.pas, so errors.pas is obsolete
  497.  
  498.   Revision 1.6  1998/02/13 10:35:33  daniel
  499.   * Made Motorola version compilable.
  500.   * Fixed optimizer
  501.  
  502.   Revision 1.5  1998/02/12 11:50:32  daniel
  503.   Yes! Finally! After three retries, my patch!
  504.  
  505.   Changes:
  506.  
  507.   Complete rewrite of psub.pas.
  508.   Added support for DLL's.
  509.   Compiler requires less memory.
  510.   Platform units for each platform.
  511.  
  512.   Revision 1.4  1998/01/24 23:08:19  carl
  513.     + compile time range checking should logically always be on!
  514.  
  515.   Revision 1.3  1998/01/23 17:12:20  pierre
  516.     * added some improvements for as and ld :
  517.       - doserror and dosexitcode treated separately
  518.       - PATH searched if doserror=2
  519.     + start of long and ansi string (far from complete)
  520.       in conditionnal UseLongString and UseAnsiString
  521.     * options.pas cleaned (some variables shifted to globals)gl
  522.  
  523.   Revision 1.2  1998/01/09 09:10:03  michael
  524.   + Initial implementation, second try
  525.  
  526. }
  527.